Freelog 22/freelog 22.iso/Prog/Djgpp/GPC2952B.ZIP/doc/gpc/demos/pipedemo.pas

Pascal/Delphi Source File | 2001-02-09 | 5.2 KB | 154 lines

{
GPC demo program for the Pipe unit.
Inter-process communication using pipes on multi-tasking systems,
emulated on single-tasking systems.

Copyright (C) 1999-2001 Free Software Foundation, Inc.

Author: Frank Heckenbach <[e-mail]>

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as
published by the Free Software Foundation, version 2.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

As a special exception, if you incorporate even large parts of the
code of this demo program into another program with substantially
different functionality, this does not cause the other program to
be covered by the GNU General Public License. This exception does
not however invalidate any other reasons why it might be covered
by the GNU General Public License.
}

program PipeDemo;

uses GPC, Pipe;

const
  ResultMessage : array [TWaitPIDResult] of TString =
    ('did not terminate with status ',
     'terminated with status ',
     'was teminated by signal ',
     'was stopped by signal ',
     'did something unexpected with status ');

var
  ToInput : Text;
  FromOutput, FromStdErr : File;
  Process : PPipeProcess;
  WaitPIDResult : TWaitPIDResult;
  Status : Integer;
  Files : array [1 .. 2] of PAnyFile;

{ Check for output while reading input. }
procedure CheckProcessOutput (TimeOut : LongInt);
const Names : array [1 .. 2] of String [6] = ('Output', 'StdErr');
var
  Nr, BytesRead : Integer;
  LastNr : static Integer = 0;
  Buffer : array [1 .. 256] of Char;
begin
  Nr := - 1;
  while (Nr <> 0) and ((Files [1] <> nil) or (Files [2] <> nil)) do
    begin
      Nr := IOSelectRead (Files, TimeOut);
      if Nr < 0 then
        begin
          Writeln (StdErr, 'Error in `IOSelect''');
          Halt (1)
        end;
      if Nr > 0 then
        begin
          BlockRead (File (Files [Nr]^), Buffer, SizeOf (Buffer), BytesRead);
          if BytesRead = 0 then
            Files [Nr] := nil
          else
            begin
              if LastNr <> Nr then
                begin
                  LastNr := Nr;
                  Write ('[', Names [Nr], ']')
                end;
              Write (Buffer [1 .. BytesRead])
            end
        end
    end
end;

procedure DemoProcedure;
var s : TString;
begin
  Writeln (StdErr, 'Forking, but not executing another process...');
  while not EOF do
    begin
      Readln (s);
      Writeln ('Writing `', s, ''' to Output.');
      Writeln (StdErr, 'Writing `', s, ''' to Error.')
    end
end;

begin
  Writeln ('Demo for using pipes and forking. By default, the program will fork');
  Writeln ('and execute DemoProc as a separate executable, and emulate this on');
  Writeln ('limited operating systems (e.g., Dos). If you give the command line');
  Writeln ('parameter `-f'', the program will only fork, but not execute');
  Writeln ('another process, but rather an internal procedure.');
  Writeln;
  if PipeForking
    then Writeln ('Using fork on this system.')
    else Writeln ('Emulating fork on this system.');
  Writeln;
  { Also search for demoproc in the directory of this executable, if available }
  SetEnv (PathEnvVar, DirFromPath (ExecutablePath) + PathSeparator + GetEnv (PathEnvVar));
  { Start a process with pipes }
  {$I-}
  if ParamStr (1) = '-f'
    then Pipe (ToInput, (*@@anyfile*)AnyFile( FromOutput), (*@@anyfile*)AnyFile( FromStdErr), '', null, GetCEnvironment, Process, DemoProcedure)
    else Pipe (ToInput, (*@@anyfile*)AnyFile( FromOutput), (*@@anyfile*)AnyFile( FromStdErr), 'demoproc', null, GetCEnvironment, Process, nil);
  {$I+}
  if IOResult <> 0 then
    begin
      Writeln (StdErr, 'Could not create pipe to `demoproc''. Please compile `demoproc.pas'' first,');
      Writeln (StdErr, 'and make sure the resulting executable can be found in your PATH.');
      Halt (1)
    end;

  { Set the variables where the process' status will be stored. }
  Process^.Result := @WaitPIDResult;
  Process^.Status := @Status;

  Files [1] := (*@@anyfile*)PAnyFile( @FromOutput);
  Files [2] := (*@@anyfile*)PAnyFile( @FromStdErr);

  { Pipe some input to the process }
  CheckProcessOutput (0);
  Writeln (ToInput, 'foo');
  CheckProcessOutput (0);
  Sleep (1);
  Writeln (ToInput, 'bar');
  CheckProcessOutput (0);

  Close (ToInput); { It's important to close ToInput here, so the process
    will terminate. However, the effects of not closing ToInput are quite
    different under Unix (waiting for more input from FromOutput or
    FromStdErr) and Dos (never starting the process in the first place
    and therefore not getting any data from FromOutput and FromStdErr!). }

  { Read all the remaining output }
  CheckProcessOutput (- 1);

  Close (FromOutput);
  Close (FromStdErr);
  Writeln ('The process ', ResultMessage [WaitPIDResult], Status, '.');
  if (WaitPIDResult = PIDExited) and (Status = 0) then Writeln ('This means success.')
end.